perm filename PT2.F4[MSS,LCS]5 blob
sn#194601 filedate 1976-01-01 generic text, type T, neo UTF8
00100 SUBROUTINE PT2
00200 INTEGER VALID
00300 DIMENSION VALID(6),NBAR(36)
00400 DATA QLINE/140.0/,HX/2./,VALID/1,4,8,2,3,-2/,SLSP/11.0/
00500 C QLINE=BASIC LINE LENGTH, HX=HEIGHT MULTIPLIER, ZL=LN. LNGTH FACTOR.
00600
00700 C ADD MORE TO VALID LATER *****
00800 COMMON /SF/KL,RT,KP,STFSZ,NAMX
00900 COMMON RS,JA,CLEFQ,AA,RQ(16),KQ,NQ,JQ,JJQ,KBQ,NAQ
01000 COMMON/STF/RSTFAC(-3/4),RSTJ2 /IVV/IV(200)
01100 COMMON /POSI/STFF(-3/4),JJ2,JPQ /LLL/L,LL,I,RXQ
01200 1/PX/KPN(1) /Q/Q(1) /PTR/KWDS(1) /XRN/RN(1)
01300 EQUIVALENCE (RQ(2),R4),(R5,RQ(3)),(R6,RQ(4)),(R7,RQ(5))
01400 1,(R8,RQ(6)),(R9,RQ(7)),(LCNT,IV(80)),(NDPY,IV(81))
01500 C TRNSP'S Bb, F, BBb, A, G, Eb.
01510 NAMQ='AAAAA'
02700 5 FORMAT(F,2I)
02800 IF(RS.NE.'OLD')GO TO 2000
02900 CALL GETFIL('PARTS')
03000 CALL FASTIN(RSTFAC,128)
03100 CALL FASTIN(KPN,JJ2)
03200 CALL FASTIN(Q,JPQ)
03500 2000 TYPE 144
03600 144 FORMAT(' STAFF SIZE, TRANSP. '$)
03700 ACCEPT 5,RSTJ2,LL
03800 IF(MOD(LL,7).EQ.0)GO TO 140
03900 DO 40 L=1,6
04000 40 IF(LL.EQ.VALID(L))GO TO 140
04100 TYPE 240
04200 GO TO 2000
04300 240 FORMAT(' THIS TRANSP NOT OFFERED')
04400 140 IF(RSTJ2.EQ.0)RSTJ2=.9
04500 L=JJ2-2
04600 TR=LL
04700 IF(LL.NE.0)CALL TRNSP(L,TR)
04800 I=L
04900 KK=1
05000 CC JJ=0
05100 CC DO 7 K=1,L
05200 CC N=PN(K)
05300 CC IF(Q(N+1).NE.4)GO TO 7
05400 CC JJ=JJ+1
05500 C FOUND A BAR LINE
05600 CC RN(JJ)=Q(N+3)
05700 CC7 CONTINUE
05800 CC ENDLN=RN(JJ)
05900 ENDLN=ENDL(JJ)
06000 C FUNCTION ENDL(JJ) (IN FAIL) DOES ALL ABOVE
06100
06200 NA=1000
06300 N=0
06400 TYPE 90,JJ
06500 RA=0
06600 90 FORMAT(' NUMBER OF BARS PER LINE: TOTAL BAR LINES='I3/)
06700 ZLINE=QLINE
06800 9 KL=0
06900 XLINE=ZLINE
07000 J=0
07100 LL=0
07200 DO 8 K=1,JJ
07300 IF(RN(K).LT.XLINE)GO TO 8
07400 KP=K-KL
07500 C NUMBER OF BARS, THIS LINE
07600 CC TYPE 89,KP
07700 KL=K
07800 J=J+1
07900 IF(IV(J).NE.KP)LL=-1
08000 IV(J)=KP
08100 XLINE=RN(K)+ZLINE
08200 IF(ENDLN-XLINE.LT.80.)XLINE=ENDLN
08300 8 CONTINUE
08400 IF(LL)TYPE 108,RA,(IV(K),K=1,J)
08500 IF(RT)GO TO 105
08600 108 FORMAT(F6.2,8(3I3,1X))
08700 CC TYPE 108
08800 CC108 FORMAT(/)
08900 CC89 FORMAT('+',I3,$)
09000 IF(J.GT.NA)GO TO 107
09100 IF(N.EQ.0)GO TO 105
09200 C SKIP IF FIRST TIME
09300 IF(N.NE.KP)GO TO 106
09400 IF(J.EQ.NA)GO TO 105
09500 106 RT=.05
09600 C SHRINK OR EXPAND?
09700 RA=RA+RT
09800 ZLINE=QLINE*RS/RA
09900 CC IF(RA.GT.J)GO TO 107
10000 GO TO 9
10050 1107 TYPE 111,KA
10100 107 FORMAT(' CAN''T DO IT!')
10200 TYPE 107
10300 105 TYPE 104,J
10400 104 FORMAT(I4,' LINES - OR TYPE N1, N2 --'$)
10500 KA=0
10600 ACCEPT 5,RA,N,KL
10700 C TYPE 0,n TO EXIT WITH n SPACING BETWEEN STAVES (2 IS DEFAULT)
10800 IF(KL.NE.0)GO TO 110
10900 C FOR SPECIFICATION OF HOW MANY BARS ON EACH LINE
10910 C NO MORE THAN 36 NUMS, INCLUDING 0S (FOR PAGE MARKS)
11000 IF(RA.EQ.0)GO TO 11
11100 IF(ZLINE.EQ.QLINE)RS=J
11200 NA=RA
11300 RT=NA-RA
11400 IF(RT)GO TO 109
11500 RA=RA-.6
11600 C CHECK THIS ↑↑↑ NUMBER!
11700 IF(N.EQ.0)GO TO 90
11800 109 ZLINE=QLINE*RS/RA
11900 GO TO 9
12000
12100 111 FORMAT(36I)
12200 110 REREAD 111,NBAR
12300 DO 112 K=36,1,-1
12400 KP=NBAR(K)
12500 KA=KA+KP
12600 112 IF(KP.EQ.0.AND.KA.EQ.0)KL=K
12700 IF(KA.NE.JJ)GO TO 1107
12800 C MISMATCH!
12900 N=26-2*MOD(KL-1,12)
13000 IF(N.EQ.26)N=0
13010 C TO SPACE OUT STAVES VERTICALLY
13100
13200 11 RA=0
13250 JEND=-1
13300 XLINE=ZLINE
13400 CLEF=-99
13500 JSLUR=0
13600 LC=1
13700 SIG=CLEF
13800 HX=2
13900 SP=2.45
13910 C DEFAULT VERT. SPACE UNITS
14000 IF(N.EQ.0)GO TO 100
14010 C SPACED OUT DEPENDING ON NUM OF LINES
14100 HX=N
14200 SP=SP+(HX-2.)*.11
14300 100 KL=1
14310 IF(JEND.EQ.0)GO TO 1000
14320 103 FORMAT(' TYPE OUTPUT FILE NAME ',$)
14328 102 FORMAT(A5)
14336 TYPE 103
14344 ACCEPT 102,NAMX
14352 IF(NAMX.EQ.' ')NAMX=NAMQ
14360 IF(LOOKF(NAMX).GE.0)GO TO 88
14368 TYPE 88,NAMX
14376 ACCEPT 102,L
14384 IF(L.EQ.'N')GO TO 103
14392 88 FORMAT(' WRITE OVER FILE ',A5,'???? '$)
14400 1000 KP=1
14410 JEND=0
14420 C FLAG FOR PAGE END - WHEN -1
14500 RT=2
14600 J=KK
14700 HGT=HX*2.
14800 LB=0
14900 MTR1=-1
15000
15100 DO 1 K=KK,I
15200 N=KPN(K)
15300 IF(Q(N+1).NE.4)GO TO 1
15400 IF(KA.EQ.0)GO TO 334
15500 LB=LB+1
15510 C BAR COUNTER
15600 IF(NBAR(LC).GT.LB)GO TO 1
15700 C FOR SPECIFIED BARS
15800 LC=LC+1
15900 LB=0
15910 IF(NBAR(LC).NE.0)GO TO 335
15920 JEND=-1
15930 LC=LC+1
16000 GO TO 335
16100 334 IF(Q(N+3).LT.XLINE)GO TO 1
16200 C FOUND LAST BAR LINE.
16300 335 RX=0
16400 MTR1=-1
16500 MTR2=-1
16600 LL=KPN(K+1)
16700 C TO ADD METER AT END OF BAR
16800 RS=Q(LL+1)
16900 IF(RS.LE.4)GO TO 3
17000 IF(RS.EQ.18)MTR1=LL
17100 C WHAT ABOUT REHRSL NUMS, ETC??
17200 LL=KPN(K+2)
17300 RS=Q(LL+1)
17400 IF(RS.LE.4)GO TO 3
17500 IF(RS.EQ.18)MTR2=LL
17600 LL=KPN(K+3)
17700 IF(Q(LL+1).EQ.18)MTR2=LL
17800 IF(MTR1.GT.0)GO TO 3
17900 MTR1=MTR2
18000 MTR2=-1
18100 C IN CASE IT SAW SOMETHING AHEAD OF NEW METER
18200 3 JJ=KP
18300 C PUTS IN STAFF
18400 RS=3.
18500 IF(RT.NE.0)GO TO 331
18600 C NEXT FOR BOTTOM STAFF. PUTS IN SPACER.
18700 RS=6.
18800 CC R8=SP
18900 331 CALL STAFF(RS,8.,0,HGT,RSTJ2,0,0,SP)
19000 HGT=HGT-HX
19100 IF(XLINE.EQ.ZLINE)GO TO 33
19200 CC IF(XLINE.LT.ENDLN)GO TO 6
19210 IF(JEND)GO TO 60
19220 C FOR PREMATURE PAGE END
19300 IF(K.NE.I)GO TO 6
19400 IF(RT.EQ.0)GO TO 6
19500 60 RX=RT
19600 RT=0
19700 CALL STAFF(6.,8.,0,0,0,0,1.,SP)
19800 C PUTS IN SPACER
19900 RT=RX
20000 6 IF(JSLUR.EQ.0)GO TO 2333
20100 LL=JSLUR
20200 JSLUR=0
20300 1333 CALL STAFF(5.,5.,0,Q(LL),Q(LL+1),SLSP,Q(LL+3),0)
20400 2333 IF(JSL2.EQ.0)GO TO 333
20500 LL=JSL2
20600 C FOR 2ND SLUR AT END OF LINE.
20700 JSL2=0
20800 GO TO 1333
20900 333 IF(CLEF.EQ.-99)GO TO 33
21000 C ONLY STAFF FOR FIRST LINE AT TOP.
21100 RX=10.*RSTJ2
21200 C THE SPACER
21300 CALL STAFF(3.,3.,1.,0,CLEF,0,0,0)
21400 IF(SIG.EQ.-99)GO TO 33
21500 RS=4.
21600 R5=SIG
21700 RX=CLEF
21800 IF(R5.LT.50)GO TO 332
21900 RX=IFIX((R5+50.)/100.)
22000 R5=R5-RX*100.
22100 C CLEF+SIG
22200 332 CALL STAFF(RS,17.,11.0*RSTJ2,0,R5,RX,0,0)
22300 RX=12.*RSTJ2
22400
22500 33 R4=RA
22600 R5=Q(N+3)
22700 RS=0
22800 R7=RT
22900 R8=RX
23000 R9=200.
23100 LL=0
23200 L=K-J+1
23300 CALL PTMOVE(Q,KPN(J))
23400 RA=R5
23500 31 IF(MTR1)GO TO 231
23600 R=200.0+2.23*RSTJ2
23700 CALL STAFF(Q(MTR1),Q(MTR1+1),R,0,Q(MTR1+5),Q(MTR1+6),0,0)
23800 C PUTS METER AFTER END OF STAFF
23900 IF(MTR2)GO TO 231
24000 R=200.0+6.7*RSTJ2
24100 CALL STAFF(Q(MTR2),Q(MTR2+1),R,0,Q(MTR2+5),Q(MTR2+6),0,0)
24200 C PUTS METER AFTER END OF STAFF
24300 231 KB=KL
24400 131 DO 30 NA=KK,K
24500 KWDS(KP)=KB
24600 KP=KP+1
24700 JK=KPN(NA)
24800 R=Q(JK+1)
24900 IF(R.EQ.5)GO TO 135
25000 IF(R.NE.44)GO TO 35
25100 135 RR=Q(JK+6)
25200 IF(RR.LT.Q(JK+3))GO TO 635
25300 C NEEDED WHEN DATA ON LINE HAS BEEN EXPANDED, NOT CONTRACTED.
25400 IF(RR.LT.199.)GO TO 37
25500 C CATCHES END OF SLUR AND VARIOUS LINES
25600 635 IF(R.EQ.5)GO TO 235
25700 C TO PUT SLUR ON NEXT LINE.
26100 235 IF(JSLUR.NE.0)GO TO 435
26200 JSLUR=JK+4
26300 GO TO 535
26400 435 JSL2=JK+4
26500 C FOR 2ND SLUR
26600 535 RR=201
26610 IF(Q(JK+8).LT.-1)RR=202
26620 Q(JK+6)=RR
26630 IF(R.EQ.5)GO TO 30
26640 GO TO 38
26700
26800 35 IF(R.NE.2)GO TO 36
26900 IF(Q(JK).LT.6.)GO TO 30
27000 CC RR=Q(IFIX(PN(NA-1))+3)
27100 RR=RIGHT(NA,-1)
27200 IF(RR.GE.199.)RR=RX
27300 CC Q(JK+3)=RR-1.6*RSTJ2+(Q(IFIX(PN(NA+1))+3)-RR)/2.
27400 Q(JK+3)=RR-1.6*RSTJ2+(RIGHT(NA,1)-RR)/2.
27500 C FUNCTION 'RIGHT' FINDS RIGHT ITEMS FOR CENTERING.
27600 C CENTERS WHOLE REST
27700 GO TO 30
27800 36 IF(R.NE.3)GO TO 34
27900 RR=Q(JK+5)
28000 IF(Q(JK).LT.3)RR=0
28100 CLEF=AMOD(RR,100.0)
28200 GO TO 30
28300 34 IF(R.NE.17)GO TO 37
28400 SIG=Q(JK+5)
28500 IF(Q(JK).GT.3)SIG=SIG+Q(JK+6)*100.
28600 C CLEF # IN P6 WITH KEY SIGS.
28700 C NEXT CHANGES CODE NUM BACK TO ORIGINAL
28800 37 IF(R.LT.33)GO TO 30
28900 38 Q(JK+1)=R/11.
29000 30 KB=KPN(NA+1)-KPN(NA)+KB
29100
29200 CC DO 31 NA=IFIX(PN(KK)),IFIX(PN(K+1)-1.)
29300 CC RN(KL)=Q(NA)
29400 CC31 KL=KL+1
29500 CC KK=K+1
29600 CALL PSHFT(KK,K)
29700 RS=RT
29800 LL='J'
29900 R4=0
30000 R5=200
30100 NA=L
30200 L=KP-JJ
30300 CALL PTMOVE(RN,KWDS(JJ))
30400 DO 47 JJ2=JJ,KP
30500 LL=KWDS(JJ2)
30600 AA=RN(LL+1)
30700 IF(AA.NE.10.AND.AA.NE.16)GO TO 347
30800 DO 147 NN=JJ2+1,KP
30900 MM=KWDS(NN)
31000 IF(RN(MM+1).NE.16)GO TO 147
31100 C FOUND THE NEXT TEXT AFTER TEXT OR NUMB.
31200 IF(RN(MM).EQ.8)GO TO 47
31300 C JUMP IF POS. IS ALREADY TAKEN CARE OF.
31400 IF(AA.EQ.10)GO TO 247
31500 C NEXT FOR TEXT FOLLOWING TEXT
31600 IF(ABS(RN(MM+4)-RN(LL+4)).GE.4)GO TO 47
31700 C JUMP IF ON DIFF. VERT. PLANE.
31800 AA=(RN(LL+9)+4.)*RSTJ2*RN(LL+5)+RN(LL+3)
31900 C SETS MINIMUM SPACE.
32000 IF(RN(MM+3).LT.AA)RN(MM+3)=AA
32100 GO TO 47
32200 247 IF(ABS(RN(MM+4)-RN(LL+4)).GT.6)GO TO 47
32300 C CHECKS VERT. POS.
32400 AA=RN(LL+4)+7
32410 IF(RN(MM+4)-AA.LT.0)RN(MM+4)=AA
32415 C MOVE WORD TO RIGHT OF NUMBER IF IT WAS TOO CLOSE
32420 GO TO 47
32430 147 CONTINUE
32440 GO TO 47
32450 347 IF(AA.NE.5)GO TO 1047
32460 C TO IMPROVE SLUR PARAMETERS
32470 R8=RN(LL+8)
32480 IF(RN(LL).LT.6)R8=0
32490 IF(R8.GT.0)GO TO 47
32500 C JUMP IF A BRACKET
32510 R=RN(LL+6)
32515
32520 DO 647 NN=JJ2+1,KP
32530 MM=KWDS(NN)
32540 C THIS IS TO FIND SLURS AT END OF OLD LINES AND EXTEND THEM
32550 IF(RN(MM+1).NE.4)GO TO 647
32560 C FIND A BAR LINE
32565 IF(RN(MM+3).GT.199.)GO TO 647
32567 C IGNORE LAST BAR OR LINE.
32570 IF(RN(MM).GT.2)GO TO 647
32575 AA=ABS(RN(MM+3)-R)
32580 IF(AA.GT.1.)GO TO 647
32590 RN(LL+6)=R+4
32600 GO TO 47
32610 647 CONTINUE
32620
32870 R7=RN(LL+7)
32880 R9=R-RN(LL+3)+(R8+1.)*2.
32890 IF(R9.GT.7)GO TO 47
32900 C NO WORK NEEDED. IT'S LONG ENOUGH
32910 IF(RN(LL).GT.5)RN(LL+8)=-1
32920 CC AA=.5
32930 R=1.
32935 IF(R7.LT.0)R=-R
32940 CC IF(R7.GT.0)GO TO 547
32950 CC AA=-AA
32960 C THE DIP IS DOWN
32970 CC R=-R
32980 547 RN(LL+4)=RN(LL+4)+R
32990 RN(LL+5)=RN(LL+5)+R
32995 C WERE +AA ↑↑↑↑↑
33000 RN(LL+7)=R
33100 GO TO 47
33110 1047 IF(AA.NE.6)GO TO 47
33120 IF(RN(LL).LT.7)GO TO 47
33130 IF(RN(LL+9).GT.200.)RN(LL+9)=0
33140 C ********** FIX THIS IN GETPTS, MOVER. IT SHOULDN'T MOVE P9 ALWAYS.
33310 47 CONTINUE
33325 IF(K.EQ.I)GO TO 2
33340 L=NA
33355 J=K+1
33370 C SO IT DOESN'T GO THRU ALL DATA
33385 RT=RT-1
33400 XLINE=RA+ZLINE
33500 IF(ENDLN-XLINE.LT.80.)XLINE=ENDLN
33600 10 IF(KL.GT.1700.OR.KP.GT.190.OR.RT.OR.JEND)GO TO 2
33700 1 IF(K.EQ.I)GO TO 3
34000 2 KWDS(KP)=KB
34100 J=1
34400 JJ2=KP+1
34500 JPQ=KB
34600 C WRITES 1 EXTRA WORD
35000 CALL PUTFIL(NAMX)
35100 LCNT=0
35200 NDPY=0
35300 CALL FASTOU(RSTFAC,128)
35400 CALL FASTOU(KWDS,JJ2)
35500 CALL FASTOU(RN,JPQ)
35600 TYPE 101,NAMX
35800 IF(KK.GE.I)CALL EXIT
35900 NAMX=NAMX+2
35950 NAMQ=NAMX
36000 CALL FINFIL
36100 GO TO 100
36110 101 FORMAT(1XA5)
36200 END
36300
36400 CC SUBROUTINE STAFF(P0,P1, P3,P4,P5,P6,P7,P8)
36500 CC COMMON/XRN/RN(2000) /SF/KL,RT,KP,RSTJ2,NAMX
36600 CC COMMON /PTR/PWDS(250),L,LL,I,IX
36700 CC PWDS(KP)=KL
36800 CC KP=KP+1
36900 CC RN(KL)=P0
37000 CC RN(KL+1)=P1
37100 CC RN(KL+2)=RT
37200 CC RN(KL+3)=P3
37300 CC RN(KL+4)=P4
37400 CC RN(KL+5)=P5
37500 CC IF(P0.LT.4.)GO TO 1
37600 CC RN(KL+6)=P6
37700 CC IF(P0.LT.5)GO TO 1
37800 CC RN(KL+7)=P7
37900 CC IF(P0.LT.6)GO TO 1
38000 CC RN(KL+8)=P8
38100 CC1 KL=KL+P0+3.
38200 CC END
38300
38400 CC FUNCTION RIGHT(NA,J)
38500 CC COMMON /PX/PN(1800) /Q/Q(9000)
38600 CC K=NA+J
38700 C J IS EITHER +1 OR -1
38800 CC1 L=PN(K)
38900 CC IF(Q(L+1).NE.16)GO TO 2
39000 CC K=K+J
39100 CC GO TO 1
39200 CC2 RIGHT=Q(L+3)
39300 CC END